perm filename NOTBMZ.OLD[MSS,LCS] blob
sn#131210 filedate 1974-11-15 generic text, type T, neo UTF8
C***** SUBRS NOTES, BMX ***********
SUBROUTINE NOTES
COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
COMMON/SCX/RHY(4),JALPHA(19),JX,RA,JZ,IRHY,RB,KA,KB,IZ
COMMON /XRN/RN(4000) /DPY/ST(4000),WDS(250),MEDIT,GO
COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
1,DBST,NFLG,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
1 /ALF/CLF,JQX,D,KQ,JG,X,ACC,T,Y,LL,RZ,RC,INP(61) /POS/POS1,POS2
COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
DIMENSION R(8,100)
EQUIVALENCE (R,RN(3001))
DATA ACMV/2.3/
POS1=0
POS2=200
444 FORMAT(' TYPE POS1, POS2 '$)
CALL SETUP
IF(RN(3921).GE.0)GO TO 8
CC IF(ST(3601).GE.0)GO TO 8
C ST(3601) IS LOC. OF RPOS(1,1)
C SKIPS IF USING SETUP ON STAFF 4
4333 TYPE 444
ACCEPT F78F,POS1,POS2
IF(POS2.EQ.0)POS2=200.
IF(POS1.GE.POS2)GO TO 4333
8 KN=0
IRHY=0
C IZ=# OF ITEMS FROM SCANR*******
IZ=I-1
CC IF(IZ.GT.50)IZ=50
C LIMIT OF 50 ITEMS***** IS NOW SET TO 100 4/74 *****
CLF=1
JQX=0
D=(POS2-POS1)/I
C D WILL SPACE ALL ITEMS EVENLY FOR NOW
C K=COUNTER FOR USEFUL ITEMS (OMITS CLEFS)
K=1
KQ=1
C LOOPS TO 7333
7 JG=0
X=V(KQ)
ACC=0
RA=2.
IF(X.LT.0)GO TO 86
C JUMP IF A CLEF OR BAR OR METER
IRHY=IRHY+1
C ADDS A RHYTHMIC UNIT
GO TO 2333
86 DO 89 LL=5,8
89 R(LL,K)=0
C TO CLEAR END OF ITEM
C TO CLEAR LAST PARAMS IN SOME ITEMS LATER
IF(IFIX(AMOD(X,100.0)).EQ.-99)GO TO 84
C JUMP IF A CLEF
IF(X.LT.-599.AND.X.GT.-610)GO TO 84
C FOUND AN EXTENDED BARLINE?
IF(X.LT.-1.)GO TO 2333
C JUMP IF IT'S A DBLSTP
RA=18.
L=-X*100.
Y=L
R(5,K)=-(X+Y/100.)*10000.+.0001
C GETS BOTTOM NUM OF METER
X=85.
GO TO 85
84 T=CLF
CLF=-(99.+X)/100.
IF(AMOD(CLF,1.).EQ.0.OR.CLF.GT.5.0)GO TO 841
C IS THE CLEF INVISIBLE?
CLF=IFIX(CLF)
GO TO 871
841 RZ=X
X=85.
C WILL SKIP LATER
Y=CLF
LL=Y
RA=3.
IF(LL.NE.5)GO TO 83
C CLF5 = BAR LINE
RA=4.
Y=1.
IF(LL.NE.CLF)Y=-599.-RZ
C 'M'=1 STF. 'M2'=2 STAVES, ETC.
831 CLF=T
GO TO 85
83 IF(Y.LT.10.)GO TO 851
C NOW A KSIG.
RA=7.
Y=Y/10.
IF(Y.GT.10.)Y=10.-Y
C CHANGES FLAT TO NEG.
R(5,K)=T-1
GO TO 831
851 Y=Y-1
C ↑↑↑↑ FOR NEW CLEFS ROUTINE 6/74
IF(JQX.NE.0)Y=Y+100.
JQX=-1
C AFTER THE FIRST TIME, THEN MINICLEFS
R(5,K)=Y
Y=0
C FOR NEW CLEF ROUTINE
85 R(4,K)=Y
2333 R(3,K)=STAFF
IF(X.GT.0)KN=KN+1
R(2,K)=KN*D+POS1
IF(X.EQ.85.)GO TO 7333
C JUMP IF REST, METER, CLEF OR BAR
RA=1.
IF(X.GT.0)GO TO 2133
X=-X
JG=-1
C DBLSTOP=-1
R(8,K)=-1.
2133 IF(X.LT.100.)GO TO 433
IF(X.LT.1000.)GO TO 233
IF(X.LT.10000.)GO TO 333
ACC=3.
C NATURAL
X=X-10000.
GO TO 433
333 ACC=2.
C SHARP
X=X-1000.
GO TO 433
233 ACC=1.
C FLAT
X=X-100.
433 Y=AMOD(X,12.0)
IF(Y.EQ.0)Y=12.
J=(Y+1)/2
IF(Y.GT.5.)J=(Y+2)/2
IF(ACC.EQ.0.OR.ACC.EQ.3.)GO TO 133
IF(ACC.EQ.1.)GO TO 533
IF(Y.EQ.1.OR.Y.EQ.6.)J=J-1
GO TO 133
533 J=J+1
133 IF(CLF.EQ.2)GO TO 633
IF(CLF.EQ.3)GO TO 733
IF(CLF.EQ.4)GO TO 833
KA=4
KB=0
GO TO 933
633 KA=2
KB=-2
GO TO 933
733 KA=3
KB=-1
GO TO 933
833 KA=2
KB=-6
933 L=(X-1)/12+1
C L IS OCTAVE
N=(L-KA)*7+J+KB
T=10.
IF(N.GE.7)T=20.
C FOR STEM DIRECTIONS - 'B' AND HIGHER HAVE STEMS DOWN.
R(4,K)=N
C N=NOTE #
IF(JG.EQ.0)GO TO 3133
C JUMP IF NOT DBLSTOP
IF(R(5,K-1).GE.10.)MX=K-1
C MX=1ST NOTE OF CHRD
T=0
L=K-MX
IF(N.LT.R(4,MX))L=-L
R(7,MX)=L
C L+=STEM UP, L-=STEM DOWN ... USED AT END OF NOTES.
RZ=ABS(R(4,MX)-FLOAT(N))-1.
C EXTENDS THE STEM!
IF(RZ.LT.1.)RZ=1.
R(8,MX)=RZ
3133 R(5,K)=ACC+T
7333 R(1,K)=RA
87 K=K+1
871 KQ=KQ+1
IF(KQ.LE.IZ)GO TO 7
IZ=K-1
C IZ IS NOW REALLY THE NUMBER OF ITEMS TO BE PROCESSED
C NEXT ADJUSTS PLACEMENT OF ACCIDENTALS AND 2NDS.
K=1
1 RX=R(7,K)
IF(RX.EQ.0.OR.R(1,K).EQ.2.)GO TO 2
C JUMP IF NO CHRD COMING
IF(RX.GT.0)GO TO 3
C JUMP IF STEM IS UP
RA=R(5,K)
IF(RA.GE.10.AND.RA.LT.20.)R(5,K)=RA+10.
C PUTS STEM DOWN IF IT WASN'T
L=K-RX
C RX=TOTAL(-1) NOTES IN CHORD
R(7,K)=0
4 RA=R(4,K)
RC=0
C INTERVAL TO PREVIOUS NOTE
C CHECK ON USE OF N ELSEWHERE
N=K+1
IF(K.LT.L)RC=RA-R(4,N)
C INTERVAL TO NEXT NOTE
IF(RC+R(6,K).EQ.1.)R(6,N)=20
C PUSHES NOTE TO LEFT
5 K=N
IF(K.GT.L)GO TO 220
GO TO 4
3 DO 30 M=2,IZ
L=M-1
IF(R(4,M)-R(4,L)+R(6,L).NE.1..OR.R(2,M).NE.
1 R(2,L))GO TO 30
R(6,M)=10
R(6,L)=30
30 CONTINUE
C TO HELP DOTTED NOTES.
C MOVES NOTE TO RIGHT OF STEM WHEN 2ND.
C THE STEM IS UP
RA=R(5,K)
IF(RA.GE.20.)R(5,K)=RA-10.
C PUTS STEM UP IF IT WASN'T
R(7,K)=0
K=1+K+RX
220 CALL ACSHFT(RX)
C L=K-1=END OF CHORD; L-ABS(RX)=START OF CHORD; +RX=↑ -RX=↓
GO TO 22
2 K=K+1
22 IF(K.LE.IZ)GO TO 1
END
SUBROUTINE BMX(RA)
C RA=NUMB. OF TAILS
DIMENSION R(8,100),VQ(100)
C VQ HOLDS TEMPORARY INFO RE. MULTIPLE BEAMS.
COMMON E,F,G,H,RJQ(34),RB,VQX,JB,B,JV,JW /XRN/RN(4000)
EQUIVALENCE (R,RN(3001)),(VQ,RN(3801))
COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
COMMON/SCX/RHY(4),JALPHA(19),JX,U,JZ,IRHY,JD,KA,KB,IZ
COMMON /SC/J,L,MK
1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,IQT
1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
CC DATA RBM/2.7/
M=IZ
DO 1 L=KN,K
1 VQ(L)=AMOD(R(7,L),10.0)
VQ(K+1)=0
C CLEARS IT FOR ROUTINE AT '3'
JB=KN
6 DO 2 L=JB,K
IF(VQ(L).LE.RA)GO TO 2
C SKIP IF EQ. TO PRESENT BEAM
RB=VQ(L)
4 IZ=IZ+1
DO 11 JD=L,K
VQX=VQ(JD)
IF(VQX.GE.RB)GO TO 20
IF(VQX.EQ.0)GO TO 11
C VQX=0 ON NON-STEM NOTES OF CHORDS. (HENCE NO TAILS)
21 B=10.
IF(L.GT.KN)GO TO 13
GO TO 16
20 JV=JD
IF(VQX.GT.RB)GO TO 21
11 JW=JD
B=20
C FINDS NEED FOR BEAM TO LEFT
16 B=B+RA
DO 5 JE=4,6
5 R(JE,IZ)=R(JE,M)
R(7,IZ)=R(7,M)+RB-RA*2.
C ADDS RIGHT NUM. OF BEAMS
IF(L.NE.JV.OR.(L.NE.KN.AND.L.NE.K))GO TO 10
B=-B
C PARTIAL, UNATTACHED BEAM IS PLACED AUTOMATICALLY IN ITMSUB.
GO TO 8
13 IF(JV.GT.L)GO TO 14
CC13 IF(JV.GT.L.OR.L.GT.JB)GO TO 14
IF(R(7,L+1).LT.10)GO TO 15
C NEXT FOR DOT ON FOLLOWING NOTE.
R(3,IZ)=10.
GO TO 19
15 R(3,IZ)=20.
C SHORT INNER BEAM TO LEFT OF STEM
19 B=-RA
GO TO 16
14 R(3,IZ)=30
C LONG INNER BEAM
JV=-JV
GO TO 16
C PARTIAL BEAM IS ON RIGHT(+) OR LEFT(-). RBM IS LENGTH.
10 IF(L.EQ.KN)GO TO 22
IF(JV.GE.0)GO TO 17
B=R(2,L)
JV=-JV
L=JV
22 IF(VQ(JW+1).GT.VQ(JW))GO TO 17
VQ(JW)=VQ(JW+1)
JW=JW-1
17 IF(L.EQ.JB.AND.B.LT.20.)L=JV
C PUTS BEAMS IN RIGHT PLACE.
18 R(2,IZ)=R(2,L)
C THIS WILL BE POS.3
R(3,IZ)=RA+R(3,IZ)
C DISPLACES
GO TO 8
2 CONTINUE
RETURN
CC8 JB=JD+1
8 JB=JW+1
R(8,IZ)=B
C FINDS SIDE (L,R) FOR PARTIAL BEAM
R(1,IZ)=999.
C FOR NEW DISPLACEMENT
IF(JB.LE.K)GO TO 6
END